home *** CD-ROM | disk | FTP | other *** search
/ Fritz: All Fritz / All Fritz.zip / All Fritz / FILES / PROGMISC / XLISP.LZH / XLISPSRC.ARC / XLOBJ.C < prev    next >
Text File  |  1986-05-17  |  12KB  |  476 lines
  1. /* xlobj - xlisp object functions */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. #ifdef MEGAMAX
  9. overlay "overflow"
  10. #endif
  11.  
  12. /* external variables */
  13. extern NODE *xlenv;
  14. extern NODE *s_stdout;
  15. extern NODE *self,*class,*object;
  16. extern NODE *new,*isnew;
  17.  
  18. /* instance variable numbers for the class 'Class' */
  19. #define MESSAGES    0    /* list of messages */
  20. #define IVARS        1    /* list of instance variable names */
  21. #define CVARS        2    /* list of class variable names */
  22. #define CVALS        3    /* list of class variable values */
  23. #define SUPERCLASS    4    /* pointer to the superclass */
  24. #define IVARCNT        5    /* number of class instance variables */
  25. #define IVARTOTAL    6    /* total number of instance variables */
  26.  
  27. /* number of instance variables for the class 'Class' */
  28. #define CLASSSIZE    7
  29.  
  30. /* forward declarations */
  31. FORWARD NODE *entermsg();
  32. FORWARD NODE *sendmsg();
  33.  
  34. /* xlclass - define a class */
  35. NODE *xlclass(name,vcnt)
  36.   char *name; int vcnt;
  37. {
  38.     NODE *sym,*cls;
  39.  
  40.     /* create the class */
  41.     sym = xlsenter(name);
  42.     cls = newobject(class,CLASSSIZE);
  43.     setvalue(sym,cls);
  44.  
  45.     /* set the instance variable counts */
  46.     setivar(cls,IVARCNT,cvfixnum((FIXNUM)vcnt));
  47.     setivar(cls,IVARTOTAL,cvfixnum((FIXNUM)vcnt));
  48.  
  49.     /* set the superclass to 'Object' */
  50.     setivar(cls,SUPERCLASS,object);
  51.  
  52.     /* return the new class */
  53.     return (cls);
  54. }
  55.  
  56. /* xladdivar - enter an instance variable */
  57. xladdivar(cls,var)
  58.   NODE *cls; char *var;
  59. {
  60.     setivar(cls,IVARS,cons(xlsenter(var),getivar(cls,IVARS)));
  61. }
  62.  
  63. /* xladdmsg - add a message to a class */
  64. xladdmsg(cls,msg,code)
  65.   NODE *cls; char *msg; NODE *(*code)();
  66. {
  67.     NODE *mptr;
  68.  
  69.     /* enter the message selector */
  70.     mptr = entermsg(cls,xlsenter(msg));
  71.  
  72.     /* store the method for this message */
  73.     rplacd(mptr,cvsubr(code,SUBR));
  74. }
  75.  
  76. /* xlsend - send a message to an object (message in arg list) */
  77. NODE *xlsend(obj,args)
  78.   NODE *obj,*args;
  79. {
  80.     NODE ***oldstk,*sym,*arglist,*val;
  81.  
  82.     /* create a new stack frame */
  83.     oldstk = xlstack;
  84.     xlsave1(arglist);
  85.  
  86.     /* get the message symbol */
  87.     sym = xlevmatch(SYM,&args);
  88.  
  89.     /* evaluate the arguments */
  90.     arglist = xlevlist(args);
  91.  
  92.     /* send the message */
  93.     val = sendmsg(obj,getclass(obj),sym,arglist);
  94.  
  95.     /* restore the previous stack frame */
  96.     xlstack = oldstk;
  97.  
  98.     /* return the result */
  99.     return (val);
  100. }
  101.  
  102. /* xlobgetvalue - get the value of an instance variable */
  103. int xlobgetvalue(pair,sym,pval)
  104.   NODE *pair,*sym,**pval;
  105. {
  106.     NODE *cls,*names;
  107.     int ivtotal,n;
  108.  
  109.     /* find the instance or class variable */
  110.     for (cls = cdr(pair); objectp(cls); cls = getivar(cls,SUPERCLASS)) {
  111.  
  112.     /* check the instance variables */
  113.     names = getivar(cls,IVARS);
  114.     ivtotal = getivcnt(cls,IVARTOTAL);
  115.     for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
  116.         if (car(names) == sym) {
  117.         *pval = getivar(car(pair),n);
  118.         return (TRUE);
  119.         }
  120.         names = cdr(names);
  121.     }
  122.  
  123.     /* check the class variables */
  124.     names = getivar(cls,CVARS);
  125.     for (n = 0; consp(names); ++n) {
  126.         if (car(names) == sym) {
  127.         *pval = getelement(getivar(cls,CVALS),n);
  128.         return (TRUE);
  129.         }
  130.         names = cdr(names);
  131.     }
  132.     }
  133.  
  134.     /* variable not found */
  135.     return (FALSE);
  136. }
  137.  
  138. /* xlobsetvalue - set the value of an instance variable */
  139. int xlobsetvalue(pair,sym,val)
  140.   NODE *pair,*sym,*val;
  141. {
  142.     NODE *cls,*names;
  143.     int ivtotal,n;
  144.  
  145.     /* find the instance or class variable */
  146.     for (cls = cdr(pair); objectp(cls); cls = getivar(cls,SUPERCLASS)) {
  147.  
  148.     /* check the instance variables */
  149.     names = getivar(cls,IVARS);
  150.     ivtotal = getivcnt(cls,IVARTOTAL);
  151.     for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
  152.         if (car(names) == sym) {
  153.         setivar(car(pair),n,val);
  154.         return (TRUE);
  155.         }
  156.         names = cdr(names);
  157.     }
  158.  
  159.     /* check the class variables */
  160.     names = getivar(cls,CVARS);
  161.     for (n = 0; consp(names); ++n) {
  162.         if (car(names) == sym) {
  163.         setelement(getivar(cls,CVALS),n,val);
  164.         return (TRUE);
  165.         }
  166.         names = cdr(names);
  167.     }
  168.     }
  169.  
  170.     /* variable not found */
  171.     return (FALSE);
  172. }
  173.  
  174. /* obisnew - default 'isnew' method */
  175. LOCAL NODE *obisnew(args)
  176.   NODE *args;
  177. {
  178.     xllastarg(args);
  179.     return (xlgetvalue(self));
  180. }
  181.  
  182. /* obclass - get the class of an object */
  183. LOCAL NODE *obclass(args)
  184.   NODE *args;
  185. {
  186.     /* make sure there aren't any arguments */
  187.     xllastarg(args);
  188.  
  189.     /* return the object's class */
  190.     return (getclass(xlgetvalue(self)));
  191. }
  192.  
  193. /* obshow - show the instance variables of an object */
  194. LOCAL NODE *obshow(args)
  195.   NODE *args;
  196. {
  197.     NODE *fptr,*obj,*cls,*names;
  198.     int ivtotal,n;
  199.  
  200.     /* get the file pointer */
  201.     fptr = (args ? xlgetfile(&args) : getvalue(s_stdout));
  202.     xllastarg(args);
  203.  
  204.     /* get the object and its class */
  205.     obj = xlgetvalue(self);
  206.     cls = getclass(obj);
  207.  
  208.     /* print the object and class */
  209.     xlputstr(fptr,"Object is ");
  210.     xlprint(fptr,obj,TRUE);
  211.     xlputstr(fptr,", Class is ");
  212.     xlprint(fptr,cls,TRUE);
  213.     xlterpri(fptr);
  214.  
  215.     /* print the object's instance variables */
  216.     for (cls = getclass(obj); cls; cls = getivar(cls,SUPERCLASS)) {
  217.     names = getivar(cls,IVARS);
  218.     ivtotal = getivcnt(cls,IVARTOTAL);
  219.     for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
  220.         xlputstr(fptr,"  ");
  221.         xlprint(fptr,car(names),TRUE);
  222.         xlputstr(fptr," = ");
  223.         xlprint(fptr,getivar(obj,n),TRUE);
  224.         xlterpri(fptr);
  225.         names = cdr(names);
  226.     }
  227.     }
  228.  
  229.     /* return the object */
  230.     return (obj);
  231. }
  232.  
  233. /* obsendsuper - send a message to an object's superclass */
  234. LOCAL NODE *obsendsuper(args)
  235.   NODE *args;
  236. {
  237.     NODE *obj,*super,*sym;
  238.  
  239.     /* get the object */
  240.     obj = xlgetvalue(self);
  241.  
  242.     /* get the object's superclass */
  243.     super = getivar(getclass(obj),SUPERCLASS);
  244.  
  245.     /* get the message selector */
  246.     sym = xlmatch(SYM,&args);
  247.  
  248.     /* send the message */
  249.     return (sendmsg(obj,super,sym,args));
  250. }
  251.  
  252. /* clnew - create a new object instance */
  253. LOCAL NODE *clnew()
  254. {
  255.     NODE *cls;
  256.     cls = xlgetvalue(self);
  257.     return (newobject(cls,getivcnt(cls,IVARTOTAL)));
  258. }
  259.  
  260. /* clisnew - initialize a new class */
  261. LOCAL NODE *clisnew(args)
  262.   NODE *args;
  263. {
  264.     NODE *ivars,*cvars,*super,*cls;
  265.     int n;
  266.  
  267.     /* get the ivars, cvars and superclass */
  268.     ivars = xlmatch(LIST,&args);
  269.     cvars = (args ? xlmatch(LIST,&args) : NIL);
  270.     super = (args ? xlmatch(OBJ,&args) : object);
  271.     xllastarg(args);
  272.  
  273.     /* get the new class object */
  274.     cls = xlgetvalue(self);
  275.  
  276.     /* store the instance and class variable lists and the superclass */
  277.     setivar(cls,IVARS,ivars);
  278.     setivar(cls,CVARS,cvars);
  279.     setivar(cls,CVALS,newvector(listlength(cvars)));
  280.     setivar(cls,SUPERCLASS,super);
  281.  
  282.     /* compute the instance variable count */
  283.     n = listlength(ivars);
  284.     setivar(cls,IVARCNT,cvfixnum((FIXNUM)n));
  285.     n += getivcnt(super,IVARTOTAL);
  286.     setivar(cls,IVARTOTAL,cvfixnum((FIXNUM)n));
  287.  
  288.     /* return the new class object */
  289.     return (cls);
  290. }
  291.  
  292. /* clanswer - define a method for answering a message */
  293. LOCAL NODE *clanswer(args)
  294.   NODE *args;
  295. {
  296.     NODE *msg,*fargs,*code,*obj,*mptr;
  297.  
  298.     /* message symbol, formal argument list and code */
  299.     msg = xlmatch(SYM,&args);
  300.     fargs = xlmatch(LIST,&args);
  301.     code = xlmatch(LIST,&args);
  302.     xllastarg(args);
  303.  
  304.     /* get the object node */
  305.     obj = xlgetvalue(self);
  306.  
  307.     /* make a new message list entry */
  308.     mptr = entermsg(obj,msg);
  309.  
  310.     /* setup the message node */
  311.     rplacd(mptr,cons(fargs,code));
  312.  
  313.     /* return the object */
  314.     return (obj);
  315. }
  316.  
  317. /* entermsg - add a message to a class */
  318. LOCAL NODE *entermsg(cls,msg)
  319.   NODE *cls,*msg;
  320. {
  321.     NODE ***oldstk,*lptr,*mptr;
  322.  
  323.     /* lookup the message */
  324.     for (lptr = getivar(cls,MESSAGES); lptr; lptr = cdr(lptr))
  325.     if (car(mptr = car(lptr)) == msg)
  326.         return (mptr);
  327.  
  328.     /* allocate a new message entry if one wasn't found */
  329.     oldstk = xlstack;
  330.     xlsave1(mptr);
  331.     mptr = consa(msg);
  332.     setivar(cls,MESSAGES,cons(mptr,getivar(cls,MESSAGES)));
  333.     xlstack = oldstk;
  334.  
  335.     /* return the symbol node */
  336.     return (mptr);
  337. }
  338.  
  339. /* sendmsg - send a message to an object */
  340. LOCAL NODE *sendmsg(obj,cls,sym,args)
  341.   NODE *obj,*cls,*sym,*args;
  342. {
  343.     NODE ***oldstk,*oldenv,*newenv,*method,*ptr,*val,*isnewmsg;
  344.     NODE *msg,*msgcls;
  345.  
  346.     /* look for the message in the class or superclasses */
  347.     for (msgcls = cls; msgcls; ) {
  348.  
  349.     /* lookup the message in this class */
  350.     for (ptr = getivar(msgcls,MESSAGES); ptr; ptr = cdr(ptr))
  351.         if ((msg = car(ptr)) && car(msg) == sym)
  352.         goto send_message;
  353.  
  354.     /* look in class's superclass */
  355.     msgcls = getivar(msgcls,SUPERCLASS);
  356.     }
  357.  
  358.     /* message not found */
  359.     xlerror("no method for this message",sym);
  360.  
  361. send_message:
  362.     /* create a new stack frame */
  363.     oldstk = xlstack;
  364.     xlstkcheck(5);
  365.     xlsave(oldenv);
  366.     xlsave(newenv);
  367.     xlsave(method);
  368.     xlsave(ptr);
  369.     xlsave(val);
  370.  
  371.     /* get the method for this message */
  372.     method = cdr(msg);
  373.  
  374.     /* make sure its a function or a subr */
  375.     if (!subrp(method) && !consp(method))
  376.     xlfail("bad method");
  377.  
  378.     /* create an 'object' stack entry */
  379.     newenv = xlframe(NIL);
  380.     rplaca(newenv,cons(obj,msgcls));
  381.  
  382.     /* create a new environment frame */
  383.     newenv = xlframe(newenv);
  384.     oldenv = xlenv;
  385.  
  386.     /* bind the symbol 'self' */
  387.     xlbind(self,obj,newenv);
  388.  
  389.     /* evaluate the function call */
  390.     if (subrp(method)) {
  391.     xlenv = newenv;
  392.     val = (*getsubr(method))(args);
  393.     }
  394.     else {
  395.  
  396.     /* bind the formal arguments */
  397.     xlabind(car(method),args,newenv);
  398.     xlenv = newenv;
  399.  
  400.     /* execute the code */
  401.     for (ptr = cdr(method); ptr; )
  402.         val = xlevarg(&ptr);
  403.     }
  404.  
  405.     /* restore the environment */
  406.     xlenv = oldenv;
  407.  
  408.     /* after creating an object, send it the ":isnew" message */
  409.     if (car(msg) == new && val)
  410.     sendmsg(val,getclass(val),isnew,args);
  411.  
  412.     /* restore the previous stack frame */
  413.     xlstack = oldstk;
  414.  
  415.     /* return the result value */
  416.     return (val);
  417. }
  418.  
  419. /* getivcnt - get the number of instance variables for a class */
  420. LOCAL int getivcnt(cls,ivar)
  421.   NODE *cls; int ivar;
  422. {
  423.     NODE *cnt;
  424.     if ((cnt = getivar(cls,ivar)) == NIL || !fixp(cnt))
  425.     xlfail("bad value for instance variable count");
  426.     return ((int)getfixnum(cnt));
  427. }
  428.  
  429. /* listlength - find the length of a list */
  430. LOCAL int listlength(list)
  431.   NODE *list;
  432. {
  433.     int len;
  434.     for (len = 0; consp(list); len++)
  435.     list = cdr(list);
  436.     return (len);
  437. }
  438.  
  439. /* xloinit - object function initialization routine */
  440. xloinit()
  441. {
  442.     /* don't confuse the garbage collector */
  443.     class = object = NIL;
  444.  
  445.     /* enter the object related symbols */
  446.     self    = xlsenter("SELF");
  447.     new        = xlsenter(":NEW");
  448.     isnew    = xlsenter(":ISNEW");
  449.  
  450.     /* create the 'Class' object */
  451.     class = xlclass("CLASS",CLASSSIZE);
  452.     setelement(class,0,class);
  453.  
  454.     /* create the 'Object' object */
  455.     object = xlclass("OBJECT",0);
  456.  
  457.     /* finish initializing 'class' */
  458.     setivar(class,SUPERCLASS,object);
  459.     xladdivar(class,"IVARTOTAL");    /* ivar number 6 */
  460.     xladdivar(class,"IVARCNT");        /* ivar number 5 */
  461.     xladdivar(class,"SUPERCLASS");    /* ivar number 4 */
  462.     xladdivar(class,"CVALS");        /* ivar number 3 */
  463.     xladdivar(class,"CVARS");        /* ivar number 2 */
  464.     xladdivar(class,"IVARS");        /* ivar number 1 */
  465.     xladdivar(class,"MESSAGES");    /* ivar number 0 */
  466.     xladdmsg(class,":NEW",clnew);
  467.     xladdmsg(class,":ISNEW",clisnew);
  468.     xladdmsg(class,":ANSWER",clanswer);
  469.  
  470.     /* finish initializing 'object' */
  471.     xladdmsg(object,":ISNEW",obisnew);
  472.     xladdmsg(object,":CLASS",obclass);
  473.     xladdmsg(object,":SHOW",obshow);
  474.     xladdmsg(object,":SENDSUPER",obsendsuper);
  475. }
  476.